perm filename FASLAP.253[MAC,LSP] blob
sn#211954 filedate 1976-04-22 generic text, type T, neo UTF8
;;; **************************************************************
;;; ***** MACLISP ****** LISP ASSEMBLER (FASLAP) *****************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1975 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
;;; THIS ASSEMBLER IS NORMALLY PART OF THE COMPILER, AND PRODUCES
;;; BINARY (FASL) FILES SUITABLE FOR LOADING WITH FASLOAD.
(DECLARE
(COUTPUT '(FASLAPSETUP/| T)) ;HAVE NECESSARY SYMS SET UP SO DDTSYMS IN
;THIS FILE WONT ACTUALLY CAUSE REQUESTS TO DDT
((LAMBDA (Y)
(DO X (READ) (READ) (EQ (EVAL X) 'FASL-TIME-STUFF) (SETQ Y (CONS X Y)))
(MAPC 'COUTPUT
(XCONS Y
(CONS 'DECLARE (MAPCAR '(LAMBDA (X) '(EVAL (READ))) Y))))
(SETQ MUMBLE NIL)
(SETQ MUMBLE
(XCONS (MAPCAN '(LAMBDA (X)
(AND (EQ (CAR X) 'SETSYNTAX)
(SETQ MUMBLE (CONS '(EVAL (READ)) MUMBLE))
(LIST (LIST 'SETSYNTAX (CADR X) (CADDR X) NIL))))
(NREVERSE Y))
(CONS 'DECLARE MUMBLE)))
)
NIL)
(SPECIAL FASLEVAL SYMBOLS CURRENTFN MAINSYMPDL ENTRYNAMES
MESSIOC LASTENTRY ATOMINDEX BINCT FSLFLD MSDIR
EXPR COBARRAY UNFASLCOMMENTS LITERALS SYMPDL UFFIL
AMBIGSYMS UNDEFSYMS DDTSYMS SOBARRAY MSDEV GOFOO
UNFASLCRFL UNFASLSIGNIF ALLATOMS DATA CREADTABLE
IMOSAR LDFNM TTYNOTES CURRENTFNSYMS DDTSYMP NIOP/|
SYMBOLSP CLPROGN LITCNT LITLOC LITERALP LOC FILOC
FASLPUSH FBF-AUX OPENIMAGEOUT FBARP MSGFILES OUTFILES)
(*EXPR FASLAP0 FASLAPBARF FASLMAIN FASLPASS1 MOBYSYMPOP
FASLPASS2 FASLEVAL LAPCONST MSOUT
FASLPLUS FASLDIFF FASLMINUS FASLNEGLIS FASLINIT
ATOMINDEX *DDTSYM BLOBLENGTH FASLDEFSYM COLLECTATOMS
MAKEWORD OPENIMAGEOUT IMAGEOUT FASLOUT FBF-AUX
REMPROPL MESOUT LREMPROP BUFFERBIN LISTOUT
SUBMATCH MUNGEABLE ARGSINFO)
(COND ((STATUS FEATURE NEWIO))
(T (*EXPR OUT CLOSE RENAME)
(*LEXPR OPEN)))
(FIXNUM (BLOBLENGTH) (ATOMINDEX) (ARGSINFO)
(RECLITCOUNT) N I TYP FILOC LOC LITLOC LITCNT BINCT)
(ARRAY* (NOTYPE (LCA 16.) (BSAR 9.) (NUMBERTABLE 127.))
(FIXNUM (BTAR 9.) (BXAR 9.)))
(GENPREFIX /|FL)
(MAPEX T)
(SETQ UNFASLCOMMENTS NIL)
(DO ((X NIL (READ))) ;SNARF DOWN MACROS, ETC
((EQ (EVAL X) 'END-OF-FASL-COMPILE-FACTS))))
(SETSYNTAX '/#
'MACRO
'(LAMBDA NIL (COND ((= (TYIPEEK) 43)
(TYI) ;FLUSH SECOND #
(EVAL (READ)))
(T ((LAMBDA (DATA FFVL)
(AND (SETQ FFVL (GET (CAR DATA) 'MACRO))
(SETQ DATA (FUNCALL FFVL DATA)))
DATA)
(READ) NIL)))))
(SETSYNTAX '/[ 'SPLICING ;CONDITIONAL ASSEMBLY HACK
(FUNCTION (LAMBDA NIL ;LOOK SORT OF LIKE MIDAS IF'S
((LAMBDA (IF FLAG)
(COND ((EQ IF 'IFE))
((EQ IF 'IFN) (SETQ IF NIL))
((EQ IF 'IFP) (SETQ IF (EVAL FLAG) FLAG NIL))
((BREAK LOSING-IF T)))
(OR (MEMQ FLAG (STATUS FEATURES))
(SETQ IF (NOT IF)))
(AND IF (DO ((Z (TYI) (TYI)) (N 1))
((ZEROP N))
(COND ((= Z '133) (SETQ N (1+ N)))
((= Z '135) (SETQ N (1- N)))))))
(READ) (READ))
NIL)))
(SETSYNTAX '/] 'SPLICING (FUNCTION (LAMBDA NIL NIL))) ;RIGHT BRACE
(DEFPROP IMOBFL 200 SYM) ;LENGTH OF IMAGEOUT'S BUFFER
'FASL-TIME-STUFF
;;; EXPAND IS A MASTER MACRO WHICH CLOBBERS THE MACRO CALL WITH THE
;;; RESULT OF THE CALL. IN ADDITION, IT MAKES IT EASY TO DESCRIBE
;;; THE RESULT BY SUBSTITUTING THROUGH A GIVEN TEMPLATE.
;;; IT IS ASSUMED THAT THE DUMMY PARAMETER OF THE CALLING MACRO
;;; IS X; I.E., IT IS DEFINED AS (DEFUN FOO MACRO (X) (EXPAND ...)).
(DEFUN EXPAND MACRO (QQQ)
(LIST 'QUOTE
((LAMBDA (WWW)
(RPLACA X (CAR WWW))
(RPLACD X (CDR WWW)))
(SUBLIS (MAPCAR (FUNCTION
(LAMBDA (HHH)
(CONS (CAR HHH)
(EVAL (CADR HHH)))))
(CADR QQQ))
(CADDR QQQ)))))
;;; DEFINE IS A MACRO WHICH EXPANDS INTO (DEFUN <FN> MACRO ...).
;;; IT ALLOWS MACRO DEFINITIONS TO BE WRITTEN IN A NATURAL WAY,
;;; USING DUMMY PARAMETERS AND A TEMPLATE.
(DEFUN DEFINE MACRO (QQQ)
(LIST 'DEFUN
(CADR QQQ)
'MACRO
'(X)
(LIST 'EXPAND
(DO ((RRR (CADDR QQQ) (CDR RRR))
(CCC '(CDR X) (LIST 'CDR CCC))
(LLL NIL
(CONS (LIST (CAR RRR)
(LIST 'CAR CCC))
LLL)))
((ATOM RRR)
(AND RRR
(SETQ LLL
(CONS (LIST RRR CCC) LLL)))
(NREVERSE LLL)))
(CADDDR QQQ))))
(DEFINE PUSH (FROB PDL) (SETQ PDL (CONS FROB PDL)))
(DEFINE SYMBOLP (FROB) (EQ (TYPEP FROB) 'SYMBOL))
(DEFUN PRINFUN MACRO (Y)
(LIST 'QUOTE
(CONS 'LAMBDA
(CONS NIL
(MAPCAR '(LAMBDA (Z)
(COND ((OR (ATOM Z) (NOT (EQ (CAR Z) 'QUOTE)))
(LIST 'PRIN1 Z))
(T (LIST 'PRINC Z))))
(CDDR (EVAL (CADR Y))))))))
(DEFUN TTYINFO MACRO (X)
(SETQ X (CONS NIL X)) ;SINCE PRINFUN IS SET UP FOR FBF,
(LIST 'AND ; WHICH HAS GOODIES BEGINNING IN 3RD ELT OF LIST
'TTYNOTES
(SUBST (PRINFUN X)
'FUN
'(PROG (↑R ↑W) (TERPRI) (FUN)))))
(DEFUN FBF MACRO (X)
(EXPAND ((TYPE (CADR X))
(FUN (PRINFUN X)))
(FASLAPBARF TYPE (FUNCTION FUN))))
(DEFUN RGCALL MACRO (X)
(SUBST (CADR X)
'FUN
(COND ((NOT (MEMQ COMPILER-STATE '(TOPLEVEL NIL)))
'(SUBRCALL T (GET FUN 'SUBR)))
('(FUNCALL FUN)))))
'END-OF-FASL-COMPILE-FACTS
;;; THESE ARE FUNCTIONS WHICH FASLAP USES BUT ARE ALSO PART OF COMPLR.
;;; WE WANT THEM TO BE DEFINED WHEN RUNNING INTERPRETIVELY, BUT WE DON'T WANT
;;; COMPLR TO SEE THEM WHEN COMPILING THE REST OF FASLAP.
;;; ALSO INCLUDED HERE ARE THINGS WHICH ARE TO BE USED ONLY FOR INTERPRETIVE RUNNING.
;;; FLUSH STUFF INTENDED ONLY FOR INTERPRETER
(DECLARE (DO ((X NIL (READ))) ((EQUAL X ''END-OF-FASL-INTERPRET-ONLY-FACTS))))
(DEFUN MSOUT (W FUN FLAG PRINLEVEL PRINLENGTH)
(PROG (↑R ↑W OUTFILES)
(COND (NIOP/| (SETQ OUTFILES MSGFILES)
(AND (NOT (EQ FLAG 'WARN))
(NOT (MEMQ 'T OUTFILES))
(SETQ ↑W NIL)))
((EQ MESSIOC CLPROGN) (SETQ ↑R T ↑W T))
((NULL MESSIOC))
(T (APPLY 'IOC MESSIOC)
(AND ↑W (NOT (EQ FLAG 'WARN)) ;OVERRIDE TTY SWITCH IF THIS
(NOT (EQ MESSIOC CLPROGN)) ;IS NOT MERELY A WARNING
(SETQ ↑W NIL))))
(AND ↑R (SETQ UNFASLSIGNIF ↑R))
(PRINC '|/
/(COMMENT **** |)
(COND (W (PRIN1 W) (PRINC '| |)))
#(RGCALL FUN)
(COND (TOPFN (PRINC '| IN FUNCTION |) (PRIN1 TOPFN)))
(PRINC '/))
(COND ((MEMQ FLAG '(ERRFL DATA))
((LAMBDA (↑W ↑R ARGS)
(AND DATAERRP (PRINC '|/
; DATA ERROR - TO PROCEED TYPE }P |))
(BREAK DATA T)
(TERPRI))
NIL NIL W)
(COND ((EQ FLAG 'ERRFL) (SETQ ERRFL T))
(T (ERR 'DATA))))
((EQ FLAG 'BARF)
(PRINC '|/
;%%%%%%%% COMPILER ERROR - CALL JONL %%%%%%%%|)
((LAMBDA (OBARRAY READTABLE ARGS) (BREAK BARF BARFP))
OBARRAY READTABLE W)
(TERPRI)
(ERR 'BARF)))))
;;; TWO WAYS TO GET RID OF MANY PROPERTIES.
(DEFUN REMPROPL (NAME L) (MAPC '(LAMBDA (X) (REMPROP X NAME)) L)) ;REMOVE A PROP FROM MANY ATOMS
(DEFUN LREMPROP (NAME L) (MAPC '(LAMBDA (X) (REMPROP NAME X)) L)) ;REMOVE MANY PROPS FROM ONE ATOM
(DEFUN FASL-TRY FEXPR (L) ;A TEST FUNCTION
(COND (L (AND (NULL (CDDR L)) (SETQ L (APPEND L (CRUNIT)))))
((SETQ L '(COUNT LAP DSK GLS))))
(FASLAP0 (CONS (CAR L) (CONS 'FASL (CDDR L)))
(LIST L)))
(MAPC '(LAMBDA (X Y) (AND (NOT (BOUNDP X)) (SET X (EVAL Y))))
'(CLPROGN GOFOO COBARRAY CREADTABLE)
'((LIST (COPYSYMBOL 'PROGN NIL)) (COPYSYMBOL 'GOFOO NIL) OBARRAY READTABLE))
(SETQ NOUUO T TTYNOTES T UNFASLCOMMENTS T DISOWNED NIL BARFP T MESSIOC NIL)
(FASLAPSETUP/| T)
(ALLOC '(LIST (20000 70000 .25) FIXNUM (6000 24000 .25) SYMBOL (3000 15000 1000)))
'END-OF-FASL-INTERPRET-ONLY-FACTS
;;; FASLAPBARF IS USED TO PRINT MESSAGES INTO THE UNFASL FILE
;;; (AND POSSIBLY ALSO TO THE TTY). IT IS USUALLY INVOKED
;;; THROUGH THE FBF MACRO. THE FIRST ARGUMENT CAUSES THE
;;; MESSAGE TO APPEAR ON THE TTY IFF NON-NIL; IF IT IS
;;; "BARF", IT INDICATES A BUG IN FASLAP (PROBABLY).
(DEFUN FASLAPBARF (BARFF FUN)
(COND ((EQ BARFF 'BARF) (SETQ FBF-AUX FUN FBARP T)
(MSOUT NIL 'FBF-AUX BARFF NIL NIL))
((COND (UNFASLCOMMENTS)
((EQ BARFF 'DATA) (SETQ FBARP T) T)
(BARFF))
(PROG (↑R ↑W)
(SETQ ↑R T)
(COND ((NULL MESSIOC))
((EQ MESSIOC CLPROGN) (SETQ ↑R (SETQ ↑W T)))
(T (APPLY 'IOC MESSIOC)))
(AND (NULL BARFF) ;MAYBE THIS MSG ISN'T FOR A TTY'S SENSITIVE EARS
(SETQ ↑R (SETQ ↑W T))) ; [BUT WE DO HAVE REQUESTS FOR UNFASLCOMMENTS]
(TERPRI) ;PRECEDE COMMENT WITH CR/LF
(AND UNFASLCRFL (TERPRI)) ;ADD ANOTHER CR/LF IF LAST THING WASN'T A COMMENT
(PRINC '|(COMMENT **FASL** |) ;BEGIN A CoMmeNt
#(RGCALL FUN) ;CONTINUE A CEMMNOT
(PRINC '|)|) ;END A TNEMMOC
(SETQ UNFASLCRFL NIL)
(AND ↑R (SETQ UNFASLSIGNIF ↑R))))))
(DEFUN FBF-AUX () (PRINC '**FASLAP-BUG**/ ) #(RGCALL FBF-AUX) T)
;;; ***** RUN-TIME SETUP CODE FOR FASLAP *****
;;;
;;; NOTE: THE LIST OF GLOBALSYMS MUST CORRESPOND TO
;;; THE LIST OF SYMBOLS AT LOCATION LSYMS IN LISP.
(DEFUN FASLVERNO ()
(PRINC '##(MAKNAM (NCONC (EXPLODEC '|
FASLAP ASSEMBLER |)
(EXPLODEC (CADR (STATUS UREAD)))
'(/ ))))
NIL)
(DEFUN FASLINIT NIL
(GETMIDASOP NIL)
((LAMBDA (OBARRAY PROPS ACS FL)
(COND ((AND (BOUNDP 'COBARRAY)
(EQ (TYPEP COBARRAY) 'ARRAY)
(SETQ FL (ARRAYDIMS COBARRAY))
(EQ (CAR FL) 'OBARRAY)
(NOT (AND (BOUNDP 'SOBARRAY) (EQ SOBARRAY COBARRAY))))
(SETQ OBARRAY COBARRAY)
(MAPC 'INTERN PROPS)
(MAPC 'INTERN ACS)
(MAPC 'INTERN
'(% @ BLOCK ASCII SIXBIT SQUOZE CALL NCALL JCALL NJCALL
ENTRY DEFSYM BLOCK SYMBOLS BEGIN DDTSYM
THIS IS THE FOR UNFASL FILE LISP COMPILED BY COMPILER
;{THESE SYMS CAN OCCUR ONLY IN HAND-CODED LAP, AND HENCE MUST COME FROM A FILE}
;AREGET CCPOPJ CHECKI FIX2 FLOAT2 FLTSKP FXNV1 FXNV2 FXNV3 FXNV4
;INHIBIT INTREL INUM NOQUIT NUMVAL PA3 PRINTA UINITA UTIN
*LCALL *MAP *SET *STORE *UDT 0*0PUSH 0PUSH ARGLOC CARCDR
ERSETUP ERUNDO FIX1 FIX1A FLCONS FLOAT1 FXCONS GOBRK IFIX IFLOAT
IOGBND MAKUNBOUND NPUSH PDLNKJ PDLNMK SPECBIND UNBIND)))
(T (SETQ COBARRAY OBARRAY CREADTABLE READTABLE)))
(MAPATOMS '(LAMBDA (X) (LREMPROP X PROPS)))
(SETQ LDFNM (FASLAPSETUP/| NIL) MSDEV 'DSK) ;LISTS AND SET UP GLOBALSYMS
(DO ((I 0 (1+ I)) (L ACS (CDR L))) ;NOW DEFINE SYMS FOR LISP ACS
((NULL L))
(AND (NOT (EQ (CAR L) 'FOO)) (PUTPROP (CAR L) I 'SYM)))
(ARRAY LCA T 16.) (ARRAY NUMBERTABLE T 127.)
(ARRAY BTAR FIXNUM 9.) (ARRAY BXAR FIXNUM 9.) (ARRAY BSAR T 9.)
(DO I 0 (1+ I) (= I 16.) (STORE (LCA I) (CONS I '((NIL -1)))))
(SETQ IMOSAR (COND ((SETQ NIOP/| (STATUS FEATURE NEWIO)) NIL)
((*ARRAY NIL 'FIXNUM ##(1+ (GET 'IMOBFL 'SYM))))))
(SSTATUS FEATURE FASLAP)
(GCTWA))
OBARRAY
'(SYM ATOMINDEX ARGSINFO ENTRY )
'(FOO A B C AR1 AR2A T TT D R F FOO P FLP FXP SP)
NIL))
(DEFUN FASLAP0 (X Y)
(PROG (↑W ↑Q ↑R CURRENTFNSYMS LOC FILOC CURRENTFN FBARP
MAINSYMPDL SYMPDL
UNFASLCRFL UNFASLSIGNIF ENTRYNAMES ALLATOMS LITLOC DDTSYMP
ATOMINDEX SYMBOLSP LITERALS COMPILER-STATE)
(RETURN (FASL-A-FILE X Y))))
;;; FASL-A-FILE SHOULD ONLY BE CALLED BY MAKLAP, FOR MAKLAP BINDS LOTS OF LOSING SPECIAL VARIABLES
(DEFUN FASL-A-FILE (TARGETFILE SOURCEFILES)
((LAMBDA (BASE IBASE OBARRAY READTABLE MSDIR EOF WINP REALSFS)
(ERRSET
(PROGN
(GCTWA T)
(FASL-START TARGETFILE NIL)
(DO SFS SOURCEFILES (CDR SFS) (NULL SFS)
(APPLY 'UREAD (CAR SFS)) ;OPEN LAP SOURCE FILE
(PUSH (STATUS UREAD) REALSFS)
(UNFASL-MSG (CAR REALSFS))
(SETQ ↑Q T)
(DO Y
(READ EOF)
(AND ↑Q (READ EOF))
(OR (NULL ↑Q) (EQ Y EOF))
(FASLIFY Y NIL)))
(SETQ WINP T)))
(GCTWA NIL)
(COND ((OR (NULL WINP) FBARP) ;IF SOME ERROR OCCURRED,
(FBF 'DATA '|ABORTED IN | CURRENTFN
'| AFTER | LOC
'| WORDS - TOTAL WORDS = | FILOC)
(AND ↑Q (DO () ((EQ EOF (READ EOF))))) ;CLEAN OUT TO END OF FILE
(SETQ REALSFS NIL))) ;IDENTIFY LOSER TO FASL-CLOSEOUT
(FASL-CLOSEOUT TARGETFILE REALSFS TARGETFILE)
(TTYINFO (COND ((NULL (CDR SOURCEFILES)) (CAR SOURCEFILES)) (SOURCEFILES))
'| ASSEMBLED - | FILOC '| WORDS|)
(GCTWA)
WINP)
8. BASE COBARRAY CREADTABLE MSDIR (LIST NIL) NIL NIL))
(DEFUN FASLIFY (LL FL)
(PROG (Y)
(COND ((EQ FL 'LIST))
((OR (EQ FL 'LAP) (AND (NULL FL) (NOT (ATOM LL)) (EQ (CAR LL) 'LAP)))
(DO ((Z LL (AND ↑Q (READ EOF))) (EOF (LIST NIL)))
((NULL Z) (SETQ LL (NREVERSE (CONS NIL Y))))
(AND (NULL ↑Q) (FBF 'DATA '|EOF IN MIDDLE OF LAP CODE FOR | CURRENTFN))
(PUSH Z Y)))
(FL (FBF 'BARF '|LOSING FASLIFY|))
(T (SETQ Y LL LL NIL) (GO B)))
A (AND (NULL LL) (RETURN NIL))
(SETQ Y (CAR LL))
B (COND ((ATOM Y)) ;IGNORE RANDOM ATOMS
((EQ (CAR Y) 'LAP) ;PROCESS LAP
(SETQ CURRENTFN (CADR Y))
(FASLPASS1 LL)
(SETQ LL (FASLPASS2 LL))
(SETQ FILOC (+ FILOC LOC))
(AND TTYNOTES
(NOT (EQ COMPILER-STATE 'COMPILE))
(PROG (↑R ↑W)
(TERPRI)
(PRIN1 CURRENTFN)
(PRINC '| ASSEMBLED |))))
((MUNGEABLE Y) (COLLECTATOMS Y) (BUFFERBIN 16 -1←18. Y))
(T (COND ((EQ (CAR Y) 'DECLARE)
(ERRSET (MAPC 'EVAL (CDR Y)) NIL)
(SETQ Y NIL))
((OR (EQ (CAR Y) 'COMMENT) (NOT (EQ (CAR Y) 'QUOTE))))
((SUBMATCH (CADR Y) '(THIS IS THE LAP FOR))
(SETQ Y (AND UNFASLCOMMENTS
(SUBST (CADDDR (CDDADR Y))
'DATA
''(THIS IS THE UNFASL FOR LISP FILE DATA)))))
((SUBMATCH (CADR Y) '(COMPILED BY LISP COMPILER))
(SETQ Y NIL)))
(COND ((AND Y (OR UNFASLCOMMENTS (NOT (MEMQ (CAR Y) '(COMMENT QUOTE)))))
(TYO 13.) ;PUT THE NON-MUNGEABLE INTO UNFASL FILE
(COND ((AND (NOT (ATOM Y)) (EQ (CAR Y) 'QUOTE))
(PRINC '/') (SETQ Y (CADR Y))))
(PRIN1 Y) (PRINC '/ )
(SETQ UNFASLCRFL (SETQ UNFASLSIGNIF T))))))
(SETQ LL (CDR LL))
(GO A)))
(DEFUN FASL-START (FILE CONTINUEP)
(AND (NULL MSDIR) (NULL (SETQ MSDIR (CADDDR FILE))) (SETQ MSDIR (CADR (CRUNIT))))
(COND (NIOP/|
(AND (NOT CONTINUEP)
(SETQ UFFIL (OPEN (LIST (CAR FILE) 'UNFASL MSDEV MSDIR) '(OUT))))
(SETQ IMOSAR (OPEN (CONS '/.FASL/. (CONS 'OUTPUT (CDDR FILE)))
'(OUT FIXNUM DSK))))
(T (AND (NOT CONTINUEP)
(SETQ UFFIL (APPLY 'UWRITE (LIST MSDEV MSDIR)))) ;OPEN UNFASL OUTPUT FILE
(OPENIMAGEOUT (CDDR FILE) T))) ;OPEN FASL OUTPUT FILE
(FASLOUT 124641635413) ;FIRST OF TWO WORD HEADER IS SIXBIT |*FASL+|
(FASLOUT LDFNM)
(SETQ ALLATOMS NIL ENTRYNAMES NIL SYMPDL NIL
MAINSYMPDL NIL CURRENTFNSYMS NIL BINCT 0)
(FILLARRAY 'NUMBERTABLE '(NIL))
(SETQ FILOC (SETQ LITLOC (SETQ LOC (SETQ ATOMINDEX 0))))
(SETQ UNFASLCRFL (SETQ ↑W (SETQ ↑R T))))
(DEFUN UNFASL-MSG (FILE)
(PRINC '|/
'(THIS IS THE UNFASL FOR |) ;BARF OUT HEADER
(PRIN1 FILE) ; FOR UNFASL FILE
(PRINC '##(MAKNAM (NCONC (EXPLODEC '|)/
'(ASSEMBLED BY FASLAP |)
(EXPLODEC (CADR (STATUS UREAD)))
(EXPLODEC '/)/
))))
(SETQ UNFASLCRFL NIL))
(DEFUN FASL-CLOSEOUT (TARGETFILE SOURCEFILES UNFASLNAM)
(AND UNFASLNAM
(SETQ UNFASLNAM (CONS (CAR UNFASLNAM) '(UNFASL))))
(BUFFERBIN 17 0 NIL) ;END OF FILE FLAG
(COND (NIOP/| (RENAME IMOSAR TARGETFILE)
(CLOSE IMOSAR)
(SETQ IMOSAR NIL))
(T (OPENIMAGEOUT TARGETFILE NIL))) ;CLOSE BINARY OUTPUT FILE
(COND (SOURCEFILES
(FBF NIL '|TOTAL = | FILOC '| WORDS|) ;CLOSE UNFASL FILE
(COND ((NULL UNFASLNAM)) ;IF KILL-FLAG PERMITS, AND
(NIOP/| (RENAME UFFIL UNFASLNAM)
(CLOSE UFFIL)
(AND (NULL UNFASLSIGNIF) (DELETEF UFFIL)))
(T (SETQ TARGETFILE (STATUS UWRITE))
(APPLY 'UFILE UNFASLNAM)
(AND (NOT (EQUAL TARGETFILE UFFIL))
(NOT (APPLY 'AND (MAPCAR 'SAMEPNAMEP TARGETFILE UFFIL)))
(SETQ DATA (LIST TARGETFILE UFFIL))
(FBF 'BARF DATA '|UNFASL CRUNIT LOST?|))
(AND (NULL UNFASLSIGNIF) ;IF NOTHING MUCH IN IT,
(APPLY 'UKILL (APPEND UNFASLNAM TARGETFILE))))) ;THEN KILL UNFASL FILE
(SETQ UFFIL NIL))
(T (COND (NIOP/|
(DELETEF TARGETFILE) ;KILL FASL FILE, IF WRONG OR INSIGNIF
(COND ((AND UFFIL UNFASLNAM)
(RENAME UFFIL UNFASLNAM)
(CLOSE UFFIL)
(SETQ UFFIL NIL))))
(T (APPLY 'UKILL TARGETFILE)
(AND UFFIL UNFASLNAM
(PROG2 (APPLY 'UFILE UNFASLNAM) (SETQ UFFIL NIL)))))
(MOBYSYMPOP MAINSYMPDL)
(REMPROPL 'SYM CURRENTFNSYMS)))
(REMPROPL 'ENTRY ENTRYNAMES) ;FLUSH NO-LONGER-NEEDED PROPERTIES
(REMPROPL 'ARGSINFO ENTRYNAMES)
(REMPROPL 'ATOMINDEX ALLATOMS)
(FILLARRAY 'BSAR '(NIL))
(FILLARRAY 'NUMBERTABLE '(NIL))
(SETQ ALLATOMS NIL ENTRYNAMES NIL SYMPDL NIL
MAINSYMPDL NIL CURRENTFNSYMS NIL))
;;; FASLPASS1 PERFORMS PASS 1 PROCESSING FOR A LAP FUNCTION.
;;; THIS INCLUDES DEFINING SYMBOLS AND SAVING VARIOUS PIECES
;;; OF INFORMATION FOR PASS 2.
(DEFUN FASLPASS1 (Q) ;Q HAS (LAP FOO SUBR) OR WHATEVER
((LAMBDA (BASE IBASE)
(PROG (AMBIGSYMS N EXPR)
(AND (NOT (EQ (CAAR (SETQ DATA Q)) 'LAP))
(FBF 'BARF DATA '|NOT LAP LISTING|))
(SETQ LOC 0)
(SETQ CURRENTFN (CADAR Q) CURRENTFNSYMS NIL)
(COND ((GET CURRENTFN 'ENTRY) ;CAN'T REDEFINE FUNCTION IN A FILE
(FBF 'DATA CURRENTFN '| DUPLICATED FUNCTION |)
(ERR NIL)))
(PUSH CURRENTFN ENTRYNAMES)
(PUTPROP CURRENTFN FILOC 'ENTRY)
(SETQ DATA (CAR Q))
(FBF NIL FILOC '| | DATA) ;UNFASL TELLS ABOUT ENTRY POINTS
(DO Z (CDR Q) (CDR Z) (COND ((NULL Z) (FBF 'BARF '|NO NIL?|) T)
((NULL (SETQ EXPR (CAR Z)))))
(COND ((ATOM EXPR)
(FASLDEFSYM EXPR (LIST 'RELOC (+ FILOC LOC))))
((EQ (CAR EXPR) 'ENTRY) ;ENTRY POINT
(COND ((GET (CADR EXPR) 'ENTRY) ;DUPLICATION IS A NO-NO
(FBF 'DATA (CADR EXPR)
'| DUPLICATED FUNCTION IN |
CURRENTFN)
(ERR NIL))
(T (PUSH (CADR EXPR) ENTRYNAMES)
(PUTPROP (CADR EXPR) (SETQ DATA (+ FILOC LOC)) 'ENTRY)
(FBF NIL DATA '| | EXPR))))
((EQ (CAR EXPR) 'DEFSYM) ;DEFSYM
(DO X (CDR EXPR) (CDDR X) ;SO DEFINE THE SYMBOLS
(NOT (AND X (CDR X))) ;NOTE THAT EVAL IS USED,
(FASLDEFSYM (CAR X) (EVAL (CADR X))))) ; NOT FASLEVAL
((EQ (CAR EXPR) 'DDTSYM) ;DECLARE DDT SYMBOLS
(SETQ DDTSYMP T) ;REMEMBER THAT THIS FN HAD DDTSYM
(MAPC (FUNCTION *DDTSYM) (CDR EXPR))) ;TRY TO GET THEM FROM DDT
((EQ (CAR EXPR) 'EVAL) ;EVALUATE RANDOM FROBS
(MAPC (FUNCTION EVAL) (CDR EXPR)))
((EQ (CAR EXPR) 'SYMBOLS) ;SYMBOLS - FOR NOW, JUST
(SETQ SYMBOLSP T)) ; REMEMBER THAT ONE HAPPENED
((MEMQ (CAR EXPR) '(SIXBIT ASCII BLOCK)) ;HAIRY BLOBS
(SETQ LOC (+ LOC (SETQ N (BLOBLENGTH EXPR)))))
((NOT (MEMQ (CAR EXPR) '(COMMENT ARGS)))
(RECLITCOUNT EXPR T)
(SETQ LOC (1+ LOC)))))
(SETQ LITLOC LOC) ;REMEMBER WHERE TO ASSEMBLE LITERALS
(SETQ LITERALS (NREVERSE LITERALS))))
8. 8.))
(DEFUN RECLITCOUNT (EXPR FL) ;FL SAYS WHETHERON PASS1 OR NOT
(COND ((AND (CDR EXPR) ;ON PASS1, MERELY ASCERTAIN NUMBER
(CDDR EXPR) ;OF CODE WORDS USING LITERALS
(SETQ EXPR (COND ((OR (EQ (CADDR EXPR) '/@)
(EQ (CADR EXPR) '/@))
(CADDDR EXPR))
((CADDR EXPR))))
(NOT (ATOM EXPR))
(EQ (CAR EXPR) '%)
(NOT (LAPCONST (CDR EXPR))))
(COND (FL (PUSH (CDR EXPR) LITERALS) 0) ;ON PASS1, NOT REALLY INTERESTED IN COUNT
((MEMQ (CADR EXPR) '(SIXBIT ASCII BLOCK)) (BLOBLENGTH EXPR))
((1+ (RECLITCOUNT EXPR NIL)))))
(0)))
;;; FASLPASS2 PERFORMS PASS 2 PROCESSING FOR A LAP FUNCTION.
;;; THIS INCLUDES RETRIEVING INFORMATION SAVED ON PASS 1
;;; (IN PARTICULAR SYMBOLS), HANDLING DDT SYMBOLS TO BE
;;; RETRIEVED AT LOAD TIME, PROCESSING LITERALS, DEFINING
;;; ENTRY POINTS TO THE LOADER, AND OF COURSE CONVERTING
;;; INSTRUCTIONS TO BINARY CODE. THE FUNCTION MAKEWORD IS
;;; CALLED TO PROCESS INDIVIDUAL LAP STATEMENTS.
(DEFUN FASLPASS2 (Q) ;Q HAS LAP LISTING
((LAMBDA (BASE IBASE LITCNT)
(PROG (DDTSYMS AMBIGSYMS LASTENTRY ENTRYPOINTS LITERALP
UNDEFSYMS OLOC EXPR OLITERALS LL N TEM)
(SETQ OLITERALS LITERALS OLOC LOC LOC 0)
(COLLECTATOMS (CDR (SETQ EXPR (CAR Q)))) ;MUST COLLECT NAME AND TYPE OF SUBR
(PUSH (CONS (CONS (CADR EXPR) (CADDR EXPR)) (GET CURRENTFN 'ENTRY))
ENTRYPOINTS) ;SAVE ENTRY POINT INFO
(COND ((GET CURRENTFN 'SYMBOLSP) ;SYMBOLS PSEUDO ANYWHERE MAKES ENTRY DEFINED
(BUFFERBIN 15 0 CURRENTFN))) ; - OUTPUT AS DDT SYMBOL
(SETQ LASTENTRY CURRENTFN)
(DO Z (CDR Q) (CDR Z) (COND ((NULL (SETQ EXPR (CAR Z)))
(SETQ LL Z)
T))
(COND ((ATOM EXPR) ;MAYBE A TAG SHOULD BE
(COND (SYMBOLSP (BUFFERBIN 15 0 EXPR)))) ; OUTPUT AS A DDT SYMBOL
((EQ (CAR EXPR) 'ENTRY) ;ENTRY POINT
(COND ((NOT (= (SETQ N (+ FILOC LOC))
(GET (CADR EXPR) 'ENTRY))) ;BETTER BE AT
(FBF 'BARF '|PHASE SCREW AT ENTRY | ; SAME PLACE AS
(CADR EXPR) '| IN | CURRENTFN))) ; IN PASS 1
(COLLECTATOMS (CDR EXPR)) ;COLLECT NAME AND TYPE
(PUSH (CONS (CONS (CADR EXPR) ;SAVE INFO ABOUT ENTRY
(COND ((CDDR EXPR)
(CADDR EXPR))
((CADDAR Q))))
N)
ENTRYPOINTS)
(AND SYMBOLSP (BUFFERBIN 15 0 (CADR EXPR)))
(SETQ LASTENTRY (CADR EXPR)))
((EQ (CAR EXPR) 'ARGS) ;ARGS DECLARATION
(COND ((EQ (CADR EXPR) LASTENTRY) ;SHOULD BE JUST AFTER ENTRY
(PUTPROP (CADR EXPR) (CADDR EXPR) 'ARGSINFO)) ;SAVE INFO
((GET (CADR EXPR) 'ENTRY) ;TWO WAYS TO BARF AT LOSER
(FBF 'DATA EXPR '| MISPLACED ARGS INFO|))
((FBF 'DATA EXPR '| FUNCTION NOT SEEN FOR THIS INFO|))))
((EQ (CAR EXPR) 'SYMBOLS) ;TURN DDT SYMBOLS OUTPUT
(SETQ SYMBOLSP (CADR EXPR))) ; SWITCH ON OR OFF
((EQ (CAR EXPR) 'EVAL) ;EVALUATE RANDOM FROBS
(MAPC (FUNCTION EVAL) (CDR EXPR)))
((EQ (CAR EXPR) 'DDTSYM) ;SAVE DDTSYMS TO PUT
(MAPC '(LAMBDA (X) (AND (NOT (MEMQ X DDTSYMS)) (PUSH X DDTSYMS)))
(CDR EXPR)))
((NOT (MEMQ (CAR EXPR) '(DEFSYM COMMENT))) (MAKEWORD EXPR))))
(AND (OR LITERALS (NOT (= LOC LITLOC))) (GO PHAS))
(SETQ LITERALP T) ;THIS LETS FASLEVAL KNOW WE'RE DOING LITERALS
(MAPC (FUNCTION MAKEWORD) OLITERALS) ;SO ASSEMBLE ALL THEM LITERALS
(AND (NOT (= LOC (+ LITLOC LITCNT))) (GO PHAS))
(MAPC '(LAMBDA (X)
(SETQ TEM (GET (CAAR X) 'ARGSINFO))
(BUFFERBIN 13 (BOOLE 7 (LSH (ARGSINFO (CAR TEM)) 27.)
(LSH (ARGSINFO (CDR TEM)) 18.)
(CDR X))
(CAR X)))
ENTRYPOINTS)
(AND DDTSYMS ;BARF ABOUT DDT SYMBOLS
(COND ((NULL DDTSYMP)
(FBF (AND TTYNOTES T) '|UNDEFINED SYMBOLS IN | CURRENTFN
'|
CONVERTED TO DDT SYMBOLS - | DDTSYMS))
((FBF NIL '|DDT SYMBOLS IN | CURRENTFN '| - | DDTSYMS))))
(COND (UNDEFSYMS ;BARF ABOUT UNDEF SYMBOLS
(FBF 'DATA '|UNDEFINED SYMBOLS IN | CURRENTFN
'| - | UNDEFSYMS)))
(REMPROPL 'SYM CURRENTFNSYMS)
(REMPROPL 'SYM DDTSYMS)
(MOBYSYMPOP SYMPDL) ;RESTORE DISPLACED SYMBOLS
(RETURN LL) ;NORMAL EXIT
PHAS (FBF 'BARF '|LITERAL PHASE SCREW IN | CURRENTFN)))
8. 8. 0))
(DEFUN ARGSINFO (X) (COND ((NULL X) 0) ((= X 777) X) ((1+ X))))
;;; FASLEVAL IS ONLY USED BY MAKEWORD, TO EVALUATE THE
;;; FIELDS OF A LAP INSTRUCTION.
(DEFUN FASLEVAL (X) ;EVALUATE HAIRY FASLAP EXPRESSION
(COND ((NUMBERP X) X) ;A NUMBER IS A NUMBER IS A NUMBER
((ATOM X)
(COND ((EQ X '*) (LIST 'RELOC (+ FILOC LOC))) ;* IS THE LOCATION COUNTER
((GET X 'SYM)) ;TRY GETTING SYM PROPERTY
((OR (NULL X) (MEMQ X UNDEFSYMS)) 0) ;0 FOR LOSING CASES
(((LAMBDA (Y) (AND Y (PUTPROP X Y 'SYM))) (GETMIDASOP X)))
((NULL DDTSYMP) ;MAYBE CAN PASS THE BUCK ON
(PUSH X DDTSYMS) ; TO FASLOAD (IT WILL GET
(*DDTSYM X)) ; SYMBOL FROM DDT WHEN LOADING)
(T (PUSH X UNDEFSYMS) 0))) ;OH, WELL, GUESS IT'S UNDEFINED
((EQ (CAR X) 'QUOTE)
(COND ((ATOM (CADR X)) X)
((EQ (CDADR X) GOFOO) (LIST 'EVAL (CAADR X)))
(X)))
((MEMQ (CAR X) '(SPECIAL FUNCTION ARRAY EVAL)) X)
((EQ (CAR X) '%)
(COND ((NOT (= FSLFLD 1)) ;LITERALS MUST BE IN ADDRESS FIELD
(SETQ DATA X)
(FBF 'DATA DATA '| LITERAL NOT IN ADDRESS FIELD IN | CURRENTFN)
0)
((LAPCONST (CDR X))) ;MAYBE IT'S A LAP CONSTANT
((NOT LITERALP)
(SETQ LITERALS (CDR LITERALS)) ;KEEPING COUNT OF THE NUMBER OF LITERALS
((LAMBDA (RLC)
(SETQ LITCNT
(+ LITCNT
(COND ((MEMQ (CADR X) '(SIXBIT ASCII BLOCK))
(BLOBLENGTH (CDR X)))
((ZEROP (RECLITCOUNT (CDR X) NIL)) 1)
(T (SETQ RLC (+ RLC (RECLITCOUNT (CDR X) NIL)))
(- RLC LITCNT -1)))))
(LIST 'RELOC (+ FILOC LITLOC RLC)))
LITCNT))
((PROG2 NIL ;HO! HO! HO! YOU THINK THIS WILL WORK??
(FASLEVAL '*)
(MAKEWORD (CDR X))))))
((MEMQ (CAR X) '(ASCII SIXBIT)) ;A WORD OF ASCII
(CAR (PNGET (CADR X)
(COND ((EQ (CAR X) 'ASCII) 7) (6))))) ;OR OF SIXBIT
((EQ (CAR X) 'SQUOZE) ;A WORD OF SQUOZE [MAY BE EITHER
(SQOZ/| (CDR X))) ; (SQUOZE SYMBOL) OR (SQUOZE # SYMBOL)]
((EQ (CAR X) '-) ;SUBTRACTION (OR MAYBE NEGATION)
(COND ((NULL (CDDR X))
(FASLMINUS (FASLEVAL (CADR X))))
((FASLDIFF (FASLEVAL (CADR X))
(FASLEVAL (CDDR X))))))
((EQ (CAR X) '+) ;ADDITION
(FASLPLUS (FASLEVAL (CADR X))
(FASLEVAL (CDDR X))))
((CDR X) (FASLPLUS (FASLEVAL (CAR X)) ;A RANDOM LIST GETS ADDED UP
(FASLEVAL (CDR X))))
((FASLEVAL (CAR X))))) ;SUPERFLUOUS PARENS - RE-FASLEVAL
;;; THE VALUE OF FASLEVAL IS ONE OF THE FOLLOWING FROBS:
;;; <NUMBER> A NUMBER
;;; (<NUMBER> -GLITCHES-) NUMBER (PLUS GLITCHES)
;;; (RELOC <NUMBER> -GLITCHES-) RELOCATABLE VALUE (PLUS GLITCHES)
;;; (SPECIAL <ATOM>) REFERENCE TO VALUE CELL
;;; (QUOTE <S-EXPRESSION>) S-EXPRESSION CONSTANT
;;; (FUNCTION <ATOM>) REFERENCE TO FUNCTION [SAME AS (QUOTE <ATOM>)]
;;; (ARRAY <ATOM>) REFERENCE TO ARRAY POINTER
;;; FOO RESULT OF INVALID ARGS TO FASLEVAL
;;;
;;; A "GLITCH" IS ONE OF THE FOLLOWING:
;;; (NIL <NUMBER> . <SIGN>) GLOBALSYM [<NUMBER> INDICATES WHICH ONE]
;;; (<SQUOZE> NIL . <SIGN>) DDT SYMBOL, VALUE UNKNOWN [<SQUOZE> IS A NUMBER]
;;; (<SQUOZE> <VALUE> . <SIGN>) DDT SYMBOL, VALUE KNOWN TO DDT ABOVE FASLAP
;;; <SIGN> IS EITHER - FOR NEGATIVE OR NIL FOR POSITIVE.
;;;
;;; FASLPLUS, FASLMINUS, AND FASLDIFF ARE USED TO PERFORM ARITHMETIC ON THESE FROBS.
;;; NO ARITHMETIC CAN BE PERFORMED ON THE SPECIAL, QUOTE, FUNCTION, ARRAY, AND FOO FROBS.
;;; ARITHMETIC CAN BE PERFORMED ON ALL THE OTHERS, EXCEPT THAT ONE CANNOT CREATE
;;; A NEGATIVE RELOC FROB, I.E. ONE CAN SUBTRACT A RELOC FROM A RELOC, BUT NOT
;;; A RELOC FROM AN ABSOLUTE.
(DEFUN FASLPLUS (K Q) ;ADD TWO FROBS
(COND ((NUMBERP K)
(COND ((NUMBERP Q) (+ K Q))
((EQ (CAR Q) 'RELOC)
(CONS 'RELOC (CONS (+ K (CADR Q)) (CDDR Q))))
((NUMBERP (CAR Q))
(CONS (+ K (CAR Q)) (CDR Q)))
('FOO)))
((EQ (CAR K) 'RELOC)
(COND ((NUMBERP Q)
(CONS 'RELOC (CONS (+ Q (CADR K)) (CDDR K))))
((NUMBERP (CAR Q))
(CONS 'RELOC (CONS (+ (CAR Q) (CADR K))
(APPEND (CDR Q) (CDDR K)))))
('FOO)))
((NUMBERP (CAR K))
(COND ((NUMBERP Q)
(CONS (+ Q (CAR K)) (CDR K)))
((EQ (CAR Q) 'RELOC)
(CONS 'RELOC (CONS (+ (CAR K) (CADR Q))
(APPEND (CDR K) (CDDR Q)))))
((NUMBERP (CAR Q))
(CONS (+ (CAR K) (CAR Q))
(APPEND (CDR K) (CDR Q))))
('FOO)))
('FOO)))
(DEFUN FASLDIFF (K Q) ;SUBTRACT TWO FROBS
(COND ((NUMBERP K)
(COND ((NUMBERP Q) (- K Q))
((NUMBERP (CAR Q))
(CONS (- K (CAR Q)) (FASLNEGLIS (CDR Q))))
('FOO)))
((EQ (CAR K) 'RELOC)
(COND ((NUMBERP Q)
(CONS 'RELOC (CONS (- (CADR K) Q) (CDDR K))))
((EQ (CAR Q) 'RELOC)
(CONS (- (CADR K) (CADR Q))
(APPEND (CDDR K) (FASLNEGLIS (CDDR Q)))))
((NUMBERP (CAR Q))
(CONS 'RELOC
(CONS (- (CADR K) (CAR Q))
(APPEND (CDDR K)
(FASLNEGLIS (CDR Q))))))
('FOO)))
((NUMBERP (CAR K))
(COND ((NUMBERP Q)
(CONS (- (CAR K) Q) (CDR K)))
((NUMBERP (CAR Q))
(CONS (- (CAR K) (CAR Q))
(APPEND (CDR K) (FASLNEGLIS (CDR Q)))))
('FOO)))
('FOO)))
(DEFUN FASLMINUS (Q) ;NEGATE A FROB
(COND ((NUMBERP Q) (- Q))
((NUMBERP (CAR Q))
(CONS (- (CAR Q)) (FASLNEGLIS (CDR Q))))
('FOO)))
(DEFUN FASLNEGLIS (K) ;NEGATES A LIST OF GLITCHES
(MAPCAR (FUNCTION (LAMBDA (Q)
(CONS (CAR Q)
(CONS (CADR Q)
(COND ((CDDR Q) NIL)
('-))))))
K))
;;; LAPCONST IS A "SEMI-PREDICATE" WHICH WHEN APPLIED TO THE CDR
;;; OR A LITERAL DETERMINES WHETHER OR NOT IT IS ONE OF A NUMBER
;;; OF SPECIAL "LAP CONSTANTS" WHICH ARE DEFINED IN LISP (IN A
;;; TABLE AT LOCATION R70) SINCE COMPILED CODE USES THEM SO OFTEN.
;;; IF NOT, IT RETURNS NIL; IF SO, IT RETURNS A FASLEVAL FROB
;;; INDICATING A REFERENCE TO R70 AS A GLOBALSYM.
(DEFUN LAPCONST (X) ;SPECIAL LAP CONSTANTS ARE
(COND ((NOT (SIGNP E (CAR X)))
(AND (NULL (CDR X)) (LAPC1 (CAR X)))) ;(% 'NIL), (% FIX1), OR (% FLOAT1)
((NULL (CDR X)) '(0 (NIL -1))) ;(% 0) OR (% 0.0)
((OR (NOT (FIXP (CADR X)))
(NOT (= (CADR X) 0))
(NULL (SETQ X (CDDR X))))
NIL)
((NULL (CDR X)) (LAPC1 (CAR X))) ;(% 0 0 'NIL), (% 0 0 FIX1), OR (% 0 0 FLOAT1)
((AND (FIXP (CAR X))
(< (CAR X) 16. )
(> (CAR X) 0)
(FIXP (CADR X))
(= (CAR X) (CADR X)))
(LCA (CAR X))))) ;(% 0 0 N N) FOR 0 < N < 16.
(DEFUN LAPC1 (X)
(COND ((EQ X 'FIX1) '(-2 (NIL -1)))
((EQ X 'FLOAT1) '(-1 (NIL -1)))
((AND (EQ (TYPEP X) 'LIST) (EQ (CAR X) 'QUOTE) (EQ (CADR X) 'NIL)
'(0 (NIL -1))))))
;;; ATOMINDEX IS USED TO RETRIEVE THE INDEX OF AN ATOM (THIS
;;; INDEX MUST HAVE BEEN PREVIOUSLY DEFINED BY COLLECTATOMS).
;;; SYMBOL ATOMS HAVE ATOMINDEX PROPERTIES; INDICES OF
;;; NUMBERS ARE KEPT IN A HASH TABLE CALLED NUMBERTABLE.
(DEFUN ATOMINDEX (X TYPE)
(COND ((NULL X) 0)
(T (AND (NULL TYPE) (SETQ TYPE (TYPEP X)))
(SETQ TYPE (COND ((EQ TYPE 'SYMBOL) (GET X 'ATOMINDEX))
((NOT (MEMQ TYPE '(FIXNUM FLONUM BIGNUM))) NIL)
((CDR (HASSOCN X TYPE)))))
(COND ((NULL TYPE)
((LAMBDA (DATA)
(FBF 'BARF '|ATOMINDEX SCREW ON | DATA '| IN | CURRENTFN))
X)))
TYPE)))
;;; COLLECTATOMS FINDS ALL ATOMS IN AN S-EXPRESSION AND ASSIGNS AN ATOMINDEX
;;; TO EACH ONE WHICH DOESN'T ALREADY HAVE ONE. THESE INDEX ASSIGNMENTS ARE ALSO
;;; OUTPUT INTO THE BINARY FILE. IT IS THROUGH THESE INDICES THAT S-EXPRESSIONS
;;; ARE DESCRIBED TO THE LOADER.
(DEFUN COLLECTATOMS (X) ;COLLECT ALL ATOMS IN AN S-EXPRESSION
(AND X ;NIL IS ALWAYS PRE-COLLECTED
(PROG (TYPE)
A (COND ((EQ (SETQ TYPE (TYPEP X)) 'LIST)
(COLLECTATOMS (CAR X))
(AND (SETQ X (CDR X)) (GO A)))
((EQ TYPE 'SYMBOL)
(COND ((NULL (GET X 'ATOMINDEX))
(PUSH X ALLATOMS)
(PUTPROP X (SETQ ATOMINDEX (1+ ATOMINDEX)) 'ATOMINDEX)
(BUFFERBIN 12 0 X))))
((MEMQ TYPE '(FIXNUM FLONUM BIGNUM))
((LAMBDA (BKT)
(COND ((NULL (CDR BKT))
(SETQ ATOMINDEX (1+ ATOMINDEX))
(RPLACD BKT (LIST (CONS TYPE (CONS X ATOMINDEX))))
(BUFFERBIN 12 0 X))))
(HASSOCN X TYPE)))))))
(DEFUN HASSOCN (X TYPE)
(PROG (BKT OBKT FIXFLOP N I)
(COND ((SETQ FIXFLOP (MEMQ TYPE '(FIXNUM FLONUM)))
(SETQ N (LSH X 0))))
(SETQ I (\ (ABS (SXHASH X)) 127.) OBKT (NUMBERTABLE I))
A (COND ((NULL (SETQ BKT (CDR OBKT)))
(RETURN (COND (OBKT) ;RETURN (<MUMBLE> . NIL)
((STORE (NUMBERTABLE I) (LIST NIL)))))) ;THE "LAST" OF A BKT
((NOT (EQ TYPE (CAAR BKT))))
((COND (FIXFLOP (= N (CADAR BKT)))
(T (EQUAL X (CADAR BKT))))
(RETURN (CDAR BKT)))) ;RETURN (N . INDEX)
(SETQ OBKT BKT)
(GO A)))
;;; FASLDEFSYM IS USED TO DEFINE SYMBOLS; IT ALSO CHECKS FOR VARIOUS
;;; ERRORS, INCONSISTENCIES, AND AMBIGUITIES.
(DEFUN FASLDEFSYM (SYM VAL) ;DEFINE A SYMBOL
(PROG (Z)
(COND ((SETQ Z (GET SYM 'SYM)) ;MAYBE IT'S ALREADY DEFINED?
(COND ((EQUAL Z VAL) (RETURN Z)) ;REDEFINING TO SAME VALUE DOESN'T HURT
((NOT (MEMQ SYM AMBIGSYMS)) ;ELSE IT IS AN AMBIGUOUS SYMBOL
(PUSH SYM AMBIGSYMS) ;OH, WE'LL REDEFINE IT, ALL RIGHT,
(AND (NOT (MEMQ SYM CURRENTFNSYMS)) ; BUT WE'LL ALSO BARF
(SETQ MAINSYMPDL (PUSH (CONS SYM Z) SYMPDL))))))
(T (PUSH SYM CURRENTFNSYMS)))
(RETURN (PUTPROP SYM VAL 'SYM)))) ;SO DEFINE THE SYMBOL (MUST RETURN THE VALUE)
(DEFUN BLOBLENGTH (X) ;DETERMINES THE LENGTH OF A BLOB
(COND ((EQ (CAR X) 'SIXBIT) ;SIXBIT
(// (+ 5 (FLATC (CADR X))) 6))
((EQ (CAR X) 'ASCII) ;ASCII
(// (+ 4 (FLATC (CADR X))) 5))
((NUMBERP (SETQ DATA (CADR X))) DATA) ;MUST BE BLOCK - ACCEPT NUMBER
((AND (SYMBOLP DATA) ;ACCEPT SYMBOL WHOSE VALUE IS NUMBER
(NUMBERP (SETQ DATA (GET DATA 'SYM))))
DATA)
(T ;BARF AT LOSER
(SETQ DATA X)
(FBF 'DATA '|ARG FOR BLOCK EXPRESSION |
DATA '| IN | CURRENTFN '| NOT DEFINED|)
0)))
(DEFUN SUBMATCH (X Y) ;NON-NIL IFF LIST Y IS A PREFIX OF LIST X
(DO ((X X (CDR X)) (Y Y (CDR Y)))
((NULL Y) T)
(AND (NULL X) (RETURN NIL)) ;X WAS TOO SHORT
(AND (NOT (EQ (CAR X) (CAR Y))) (RETURN NIL)))) ;THEY DONT MATCH
(DEFUN MUNGEABLE (X) ;SHOULD RANDOM S-EXPR BE PUT IN BINARY FILE
(NOT (OR (MEMQ (CAR X) '(QUOTE COMMENT DECLARE)) ;NOT IF QUOTED OR COMMENT
(AND (EQ (CAR X) 'EVAL) ;NOT IF (EVAL 'FOO)
(EQ (TYPEP (CADR X)) 'LIST) ; (THIS GIVES US A HOOK TO
(EQ (CAADR X) 'QUOTE))))) ; AVOID MUNGING IF DESIRED)
(DEFUN MOBYSYMPOP (L)
(DO X L (CDR X) (NULL X)
(PUTPROP (CAAR X) (CDAR X) 'SYM)))
;;; LISTOUT OUTPUTS AN S-EXPRESSION AS A SEQUENCE OF LIST-SPECS.
;;; EACH LIST-SPEC MAY BE AS FOLLOWS:
;;; 0,,N THE ATOM WHOSE ATOMINDEX IS N
;;; 100000,,N LISTIFY THE LAST N ITEMS, TO CREATE A NEW ITEM
;;; 200000,,N MAKE A DOTTED LIST OUT OF THE LAST N+1 ITEMS
;;; A SEQUENCE OF LIST-SPECS IS TERMINATED BY A WORD WHOSE LEFT
;;; HALF IS -1. (LISTOUT DOES NOT GENERATE THIS WORD.)
(DEFUN LISTOUT (X)
((LAMBDA (TYPE)
(COND ((EQ TYPE 'RANDOM)
(FBF 'DATA '|QUOTE RANDOMNESS IN | CURRENTFN '| AT RELATIVE LOCATION | LOC))
((NOT (EQ TYPE 'LIST)) (FASLOUT (ATOMINDEX X TYPE)))
((DO ((I 0 (1+ I)) (Y X (CDR Y)) (FL) (N 0))
((OR (NULL Y) (SETQ FL (ATOM Y)))
(SETQ N (COND (FL (LISTOUT Y) 2←41) (1←41)) I (BOOLE 7 I N))
(FASLOUT I))
(LISTOUT (CAR Y))))))
(TYPEP X)))
;;; BUFFERBIN TAKES TWO ARGUMENTS: A NUMBER, WHICH IS THE
;;; RELOCATION TYPE, AND SOME OBJECT. THE FORMAT OF THIS SECOND
;;; OBJECT DEPENDS ON THE TYPE, AS FOLLOWS:
;;; # TYPE FORMAT OF SECOND AND THIRD OBJECTS
;;; 0 ABSOLUTE <FIXNUM>
;;; 1 RELOCATABLE <FIXNUM>
;;; 2 SPECIAL <FIXNUM>
;;; 3 SMASHABLE CALL <FIXNUM>
;;; 4 QUOTED ATOM <FIXNUM> ATOM
;;; 5 QUOTED LIST <FIXNUM> <LIST>
;;; 6 GLOBALSYM <FIXNUM>
;;; 7 GETDDTSYM <SQUOZE-VAL> <NIL OR FIXNUM>
;;; 10 ARRAY REFERENCE <ATOMINDEX>
;;; 11 [UNUSED]
;;; 12 ATOMINDEX INFO 0 <ATOM>
;;; 13 ENTRY INFO ARGSINFO (<NAME> . <TYPE>)
;;; 14 LOC <FIXNUM>
;;; 15 PUTDDTSYM 0 <ATOM>
;;; 16 EVAL MUNGEABLE <-N,,0> <RANDOM-SEXP>
;;; 17 END OF BINARY [IGNORED - IN PRACTICE NIL IS USED]
(DEFUN BUFFERBIN (TYP N X)
(STORE (BTAR BINCT) TYP)
(STORE (BXAR BINCT) N)
(STORE (BSAR BINCT) X)
(COND ((AND (NOT (= TYP 17)) (< BINCT 8.)) (SETQ BINCT (1+ BINCT)))
(T (DO ((N 0 (BOOLE 7 (LSH N 4) (BTAR I))) ;PACK 9 TYPE BYTES INTO
(I 0 (1+ I))) ;ONE WORD
((> I BINCT) (FASLOUT (LSH N (* 4 (- 8. BINCT))))))
(DO I 0 (1+ I) (> I BINCT)
(SETQ TYP (BTAR I) N (BXAR I))
(COND ((OR (< TYP 5) (= TYP 6) (= TYP 8.)) (FASLOUT N))
(T (SETQ X (BSAR I))
(COND ((= TYP 5)
(LISTOUT X)
(FASLOUT (BOOLE 7 -1←18. (LSH N -18.)))
(FASLOUT (SXHASH X)))
((= TYP 10.)
((LAMBDA (TYPE)
(COND ((EQ TYPE 'SYMBOL)
(SETQ X (PNGET X 7))
(FASLOUT (LENGTH X))
(MAPC 'FASLOUT X))
((EQ TYPE 'BIGNUM)
(FASLOUT (BOOLE 7 3←33.
(COND ((MINUSP X) 7←18.) (0))
(LENGTH (CDR X))))
(MAPC 'FASLOUT (REVERSE (CDR X))))
(T (FASLOUT (COND ((EQ TYPE 'FIXNUM) 1←33.) (2←33.)))
(FASLOUT X))))
(TYPEP X)))
((= TYP 11.)
(FASLOUT (BOOLE 7 (LSH (ATOMINDEX (CAR X) 'SYMBOL) 18.)
(ATOMINDEX (CDR X) 'SYMBOL)))
(FASLOUT N))
((= TYP 14.) (LISTOUT X) (FASLOUT N))
((= TYP 15.) (FASLOUT 124641635413)) ;SIXBIT FOR |*FASL+|
((= TYP 7) (FASLOUT N) (AND X (FASLOUT X)))
((= TYP 13.) (FASLOUT (SQOZ/| (LIST X))))
(T (SETQ DATA (LIST TYP N X))
(FBF 'BARF DATA '| - BUFFERBIN SCREW IN | CURRENTFN))))))
(SETQ BINCT 0))))
(DEFINE POPNCK@ (TAG)
(COND ((NULL (SETQ L (CDR L))) (GO DONE))
((EQ (CAR L) '/@) (SETQ WRD (BOOLE 7 WRD 20←18.)) (GO TAG))))
(DEFINE MKEVAL (N)
(PROG2 (SETQ FSLFLD N)
(AND (EQ (SETQ SYM (FASLEVAL (CAR L))) 'FOO) (GO MKWERR))
(SETQ TYPE (TYPEP SYM))))
(DEFUN MAKEWORD (L)
(DECLARE (FIXNUM WRD NN II REL))
(PROG (WRD NN SYM TYPE OPGL ACGL ADDRGL INDXGL NOGL REL SYL OL)
(SETQ NOGL T REL 0 WRD 0 OL L)
(COND ((EQ (CAR L) 'SQUOZE)
(BINOUT (SQOZ/| (CDR L)))
(SETQ LOC (1+ LOC))
(RETURN NIL))
((EQ (CAR L) 'BLOCK)
(SETQ TYPE (TYPEP (SETQ SYM (CADR L))))
(AND (EQ TYPE 'SYMBOL) (SETQ TYPE (TYPEP (SETQ SYM (GET SYM 'SYM)))))
(AND (NOT (EQ TYPE 'FIXNUM)) (GO MKWERR))
(DO II SYM (1- II) (ZEROP II) (BINOUT 0))
(SETQ LOC (+ LOC SYM))
(RETURN NIL))
((COND ((EQ (CAR L) 'ASCII) (SETQ NN 7) T)
((EQ (CAR L) 'SIXBIT) (SETQ NN '6) T))
(MAPC 'BINOUT (SETQ SYM (PNGET (CADR L) NN)))
(SETQ LOC (+ LOC (LENGTH SYM)))
(RETURN NIL)))
(MKEVAL 3)
(COND ((MEMQ TYPE '(FIXNUM FLONUM)) (SETQ WRD SYM))
((NOT (EQ TYPE 'LIST)) (GO MKWERR))
((EQ (CAR SYM) 'RELOC)
(SETQ REL 1 WRD (CADR SYM))
(AND (SETQ OPGL (CDDR SYM)) (SETQ NOGL NIL)))
((NUMBERP (CAR SYM)) (SETQ NOGL NIL OPGL (CDR SYM) WRD (CAR SYM)))
(T (GO MKWERR)))
A (POPNCK@ A)
(MKEVAL 2)
(COND ((EQ TYPE 'FIXNUM) (SETQ WRD (+ WRD (ROT (BOOLE 1 SYM 17) -13.))))
((NOT (EQ TYPE 'LIST)) (GO MKWERR))
((NUMBERP (CAR SYM))
(SETQ NOGL NIL ACGL (CDR SYM))
(SETQ WRD (BOOLE 7 WRD (ROT (BOOLE 1 (CAR SYM) 17) -13.))))
(T (GO MKWERR)))
B (POPNCK@ B)
(MKEVAL 1)
(COND ((EQ TYPE 'FIXNUM) (SETQ NN SYM))
((NOT (EQ TYPE 'LIST)) (GO MKWERR))
((NUMBERP (CAR SYM)) (SETQ NOGL NIL ADDRGL (CDR SYM) NN (CAR SYM)))
((PROG2 (SETQ SYL (CADR SYM)) (MEMQ (CAR SYM) '(QUOTE FUNCTION)))
(COLLECTATOMS SYL)
(SETQ REL (COND ((NOT (EQ (SETQ TYPE (TYPEP SYL)) 'LIST))
(SETQ NN (ATOMINDEX SYL TYPE)) 4)
(T (SETQ ADDRGL SYL NN 0) 5))))
((COND ((EQ (CAR SYM) 'SPECIAL) (SETQ REL 2) T)
((EQ (CAR SYM) 'ARRAY) (SETQ REL 10) T))
(COLLECTATOMS SYL)
(AND (NOT (SYMBOLP SYL)) (GO MKWERR))
(SETQ NN (ATOMINDEX SYL 'SYMBOL)))
((EQ (CAR SYM) 'RELOC)
(SETQ REL 1 NN (CADR SYM))
(AND (SETQ ADDRGL (CDDR SYM)) (SETQ NOGL NIL)))
((EQ (CAR SYM) 'EVAL)
(COLLECTATOMS SYL)
(BUFFERBIN 14. -2←18. SYL)
(SETQ REL 4 ATOMINDEX (SETQ NN (1+ ATOMINDEX))))
(T (GO MKWERR)))
(SETQ WRD (BOOLE 7 (BOOLE 1 WRD -1←18.) (BOOLE 1 NN 777777)))
C (POPNCK@ C)
(MKEVAL 0)
(COND ((MEMQ TYPE '(FIXNUM FLONUM)) (SETQ WRD (+ WRD (ROT SYM 18.))))
((NOT (EQ TYPE 'LIST)) (GO MKWERR))
((NUMBERP (CAR SYM))
(SETQ NOGL NIL INDXGL (CDR SYM) WRD (+ WRD (ROT (CAR SYM) 18.))))
(T (GO MKWERR)))
DONE (AND (= REL 4) (MEMQ (CAR OL) '(CALL JCALL NCALL NJCALL)) (SETQ REL 3))
(SETQ LOC (1+ LOC))
(BUFFERBIN REL WRD (AND (= REL 5) (PROG2 NIL ADDRGL (SETQ ADDRGL NIL))))
(COND ((NOT NOGL)
(AND OPGL (GLHAK OPGL 3))
(AND ACGL (GLHAK ACGL 2))
(AND ADDRGL (GLHAK ADDRGL 1) (GO MKWERR))
(AND INDXGL (GLHAK INDXGL 0))))
(RETURN NIL)
MKWERR
((LAMBDA (DATA) (FBF 'DATA DATA '| - ILL-FORMED EXPRESSION IN | CURRENTFN)) OL)))
(DEFUN GLHAK (GLITCH FIELD)
(DECLARE (FIXNUM FIELD))
(COND ((NULL (CAAR GLITCH))
(COND ((NOT (= FIELD 1))) ;RETURNS NON-NIL IF LOSES
(T (BUFFERBIN 6
(BOOLE 7 (COND ((CDDAR GLITCH) -4←41) (0))
(BOOLE 1 (CADAR GLITCH) 777777))
NIL)
(AND (CDR GLITCH) (GLHAK (CDR GLITCH) FIELD)))))
(T (BUFFERBIN 7
(BOOLE 7 (COND ((CDDAR GLITCH) -4←41) (0)) ;PLUS OR MINUS?
(COND ((CADAR GLITCH) 2←41) (0)) ;VALUE KNOWN AT ASSEMBLY TIME?
(ROT FIELD -4) ;FIELD NUMBER
(CAAR GLITCH)) ;SQUOZE REPRESENTATION
(CADAR GLITCH)) ;GUESS AT SYMVAL
(AND (CDR GLITCH) (GLHAK (CDR GLITCH) FIELD)))))
(DEFUN BINOUT (X) (BUFFERBIN 0 X NIL))
(DEFUN *DDTSYM (SYM) (FASLDEFSYM SYM (LIST '0 (LIST (SQOZ/| (LIST SYM)) (GETDDTSYM SYM)))))
(DEFUN FASLOUT (X)
(COND (NIOP/| (OUT IMOSAR X))
(T (IMAGEOUT X))))
;;; THIS FUNCTION LOGICALLY DIVIDES INTO TWO HALVES, WHICH HOWEVER
;;; ARE INTERRELATED. THE IMAGEOUT SERIES HANDLE THE OPENING,
;;; CLOSING, AND I/O TRANSFERS FOR THE BINARY OUTPUT FILE. AN
;;; ARRAY IS CREATED FOR USE AS AN I/O BUFFER; THE SAR OF THIS
;;; ARRAY IS MADE THE VALUE OF THE ATOM IMOSAR. TEMPORARY
;;; BUT ASYNCHRONOUS VARIABLES ARE ASSEMBLED INTO THE LISP SYSTEM
;;; AND MADE KNOWN TO FASLAP THROUGH THE FASLAPSETUP| FUNCTION
;;; WHEN FASLAP IS ASSEMBLED (THIS PROVIDES GREAT CONVENIENCE).
;;; THE BUFFERBIN SERIES HANDLES THE LOGIC OF BUFFERING OUTPUT
;;; ITEMS INTO NINE-ITEM BLOCKS FOR THE LOADER; THE ITEMS ARE
;;; KEPT ON A LIST WHICH IS THE VALUE OF THE ATOM BINWORDS.
;;; NINE ITEMS HAVE BEEN ACCUMULATED, OR AN ITEM OF TYPE 17
;;; (END OF FILE) IS OUTPUT, BUFFERBIN OUTPUTS (THROUGH
;;; IMAGEOUT) A WORD OF NINE FOUR-BIT RELOCATION BYTES FOLLOWED
;;; BY THE NINE DATA ITEMS.
;;; BUFFERBIN TAKES TWO ARGUMENTS: A NUMBER, WHICH IS THE
;;; RELOCATION TYPE, AND SOME OBJECT. THE FORMAT OF THIS SECOND
;;; OBJECT DEPENDS ON THE TYPE, AS FOLLOWS:
;;; # TYPE FORMAT OF SECOND AND THIRD OBJECTS
;;; 0 ABSOLUTE <FIXNUM>
;;; 1 RELOCATABLE <FIXNUM>
;;; 2 SPECIAL <FIXNUM>
;;; 3 SMASHABLE CALL <FIXNUM>
;;; 4 QUOTED ATOM <FIXNUM> ATOM
;;; 5 QUOTED LIST <FIXNUM> <LIST>
;;; 6 GLOBALSYM <FIXNUM>
;;; 7 GETDDTSYM <SQUOZE-VAL> <NIL OR FIXNUM>
;;; 10 ARRAY REFERENCE <ATOMINDEX>
;;; 11 [UNUSED]
;;; 12 ATOMINDEX INFO 0 <ATOM>
;;; 13 ENTRY INFO ARGSINFO (<NAME> . <TYPE>)
;;; 14 LOC <FIXNUM>
;;; 15 PUTDDTSYM 0 <ATOM>
;;; 16 EVAL MUNGEABLE <-N,,0> <RANDOM-SEXP>
;;; 17 END OF BINARY [IGNORED - IN PRACTICE NIL IS USED]
(AND (STATUS FEATURE NEWIO) (DEFPROP UTIN 0 SYM) (DEFPROP UINITA 0 SYM))
(LAP OPENIMAGEOUT SUBR)
(ARGS OPENIMAGEOUT (NIL . 2))
[IFE DEC10, (DEFSYM FSLC 14)] ;FASLAP CAN USE BVDC TEMPROARILY
;BUT DEC10 VERSION USES DSIC
(DEFSYM TTSAR 1) ;OFFSET OF TT SAR FROM SAR
(JUMPE B CLIMO)
(MOVEI B 'OUTPUT)
(CALL 2 (FUNCTION XCONS))
(MOVEI B '/.FASL/.)
(CALL 2 (FUNCTION XCONS))
(MOVEI T 7) ;BLOCK IMAGE OUTPUT MODE
(PUSHJ P,UINITA)
[IFE DEC10,
(*OPEN FSLC UTIN) ;OPEN FILE NAMED ".FASL. OUTPUT"
(LERR 0 (% SIXBIT |FILE OPEN FAILED - FASLAP!|))
] ;END OF IFE DEC10
[IFN DEC10,
(MOVE T D10NAM)
(HRRI T (SIXBIT / / / FAS))
(MOVEM T UFN1)
(HRLZM T UFN2)
(MOVE B (SPECIAL IMOSAR))
(PUSHJ P (IOO 2)) ;CROCK PATCH TO NOT MAKE ARRAY AGIN
(LERR 0 (% SIXBIT |DEVICE NOT AVAILABLE!|))
(ENTER DSIC T)
(LERR 0 (% SIXBIT |CANNOT ENTER FILE!|))
] ;END OF IFN DEC10
(MOVE A (SPECIAL IMOSAR))
(MOVEI B '(0))
(CALL 2 'FILLARRAY)
(MOVE TT UTIN)
(JSP T FXCONS)
(MOVEM A (SPECIAL OPENIMAGEOUT))
(MOVE AR2A (SPECIAL IMOSAR))
IMOINI (MOVEI TT IMOBFL)
(MOVNM TT @ TTSAR AR2A)
(MOVEI A 'T)
(JRST 0 INTREL) ;UNLKPOPJ
CLIMO (PUSH FXP INHIBIT) ;LOCKI
(SETOM 0 INHIBIT)
(PUSH P A)
(HLRZ A 0 A)
(PUSHJ P SIXMAK)
(PUSH FXP TT)
(POP P A)
(HRRZ A 0 A)
(HLRZ A 0 A)
(PUSHJ P SIXMAK)
[IFN DEC10,
(PUSH FXP TT)
(HRRZ AR2A (SPECIAL IMOSAR))
(MOVEI TT IMOBFL)
(MOVN TT @ TTSAR AR2A)
(SUBI TT IMOBFL)
(JUMPE TT GREG2)
(HRLZS 0 TT)
(HRR TT TTSAR AR2A)
(SUBI TT 1) ;DEC-10 WANTS IOWD, NOT AOBJN PTR
(SETZ D)
(OUTPUT DSIC TT)
(STATZ DSIC 740000)
(JRST 0 OFAIL)
GREG2 (MOVE T @ (SPECIAL OPENIMAGEOUT))
(MOVEM T UTIN)
(CLOSE DSIC)
(MOVE T -1 FXP)
(HLLZ TT 0 FXP)
(MOVE R USN) ;PICK UP PPN
(LOOKUP DSIC T)
(JRST 0 GREG1)
(MOVE R USN)
(SETZB T TT)
(RENAME DSIC T)
(LERR 0 (% SIXBIT CANNOT/ DELETE/ EXISTING/ FILE/ -/ FASLAP/#/!/!))
GREG1 (MOVE R USN)
(MOVE T D10NAM)
(HRRI T (SIXBIT / / / FAS))
(HRLZM T TT)
(LOOKUP DSIC T)
(JFCL 0)
(POP FXP TT)
(POP FXP T)
(MOVE R USN)
(SETZ D) ;SAIL PATCH
(HLLZS TT) ;THIS IS FOR PROPER RENAMING IN SAIL
(RENAME DSIC T)
(LERR 0 (% SIXBIT FILE/ RENAME/ LOST/ /-/ FASLAP/!))
] ;END OF IFN DEC10
[IFE DEC10,
(POP FXP (UTIN 3))
(MOVEM TT (UTIN 4))
(MOVE T @ (SPECIAL OPENIMAGEOUT))
(MOVEM T UTIN)
(SETZM 0 (UTIN 1))
(MOVEI T FSLC)
(MOVEM T (UTIN 2))
(*FDELE 0 UTIN)
FFRL (LERR 0 (% SIXBIT FASLAP/ FILE/ RENAME/ LOST/!))
(HRRZ AR2A (SPECIAL IMOSAR))
(MOVEI TT IMOBFL)
(MOVN TT @ TTSAR AR2A) ;CHECK FOR ANY DATA LEFT IN BUFFER
(SUBI TT IMOBFL)
(JUMPE TT IMOB)
(HRLZS 0 TT) ;OUTPUT LAST BLOCK OF DATA
(HRR TT TTSAR AR2A)
(*IOT FSLC TT)
IMOB (*CLOSE FSLC) ;CLOSE OUTPUT FILE
] ;END OF IFE DEC10
(MOVEI A 0)
(JRST 0 INTREL) ;UNLKPOPJ
(ENTRY IMAGEOUT SUBR)
(MOVE TT 0 1) ;GET OUTPUT VALUE
IMOTT (PUSH FXP INHIBIT)
(SETOM 0 INHIBIT)
(MOVE F TT)
(MOVE AR2A (SPECIAL IMOSAR))
(MOVEI TT IMOBFL)
(AOS D @ TTSAR AR2A) ;GET AND INCREMENT COUNT
(MOVEI TT (- IMOBFL 1) D)
(MOVEM F @ TTSAR AR2A) ;PUT WORD IN BUFFER
(JUMPN D INTREL) ;UNLKPOPJ
(HRLI TT (- IMOBFL))
(HRR TT TTSAR AR2A)
[IFN DEC10,
(SUBI TT 1)
(MOVEI D 0)
(OUT DSIC TT)
(JRST 0 IMOINI) ;NOW GO REINITIALIZE COUNTER
OFAIL (LERR 0 (% SIXBIT OUTPUT/ FAILURE/ /-/ FASLAP/!))
] ;END OF IFN DEC10
[IFE DEC10,
(*IOT FSLC TT)
(JRST 0 IMOINI) ;NOW GO REINITIALIZE COUNTER
] ;END OF IFE DEC10
NIL
;;; STUFF TO CLEAN UP AFTER READING IN OR COMPILING FASLAP
(DECLARE (MAPC 'COUTPUT MUMBLE)
(MAPC 'EVAL (CDR MUMBLE))
(DO ((X NIL (EVAL (READ)))) ((EQ X 'END-OF-FASL-EXPR-LOAD-ONLY-CLEAN-UP))))
;;; MUMBLE LIST SHOULD HAVE THE SAME SETSYNTAXES AS BELOW
(SETSYNTAX '/# 'MACRO NIL)
(SETSYNTAX '/[ 'SPLICING NIL)
(SETSYNTAX '/] 'SPLICING NIL))
'END-OF-FASL-EXPR-LOAD-ONLY-CLEAN-UP
(AND (STATUS FEATURE NEWIO) (REMPROP 'UTIN 'SYM) (REMPROP 'UINITA 'SYM))
;;; SOMEBODY ELSE (NORMALLY INITIALIZE IN COMPLR OR IN FDRV)
;;; MUST CALL FASLINIT BEFORE FASLAP CAN BE USED!
(SSTATUS FEATURE FASLAP)
(GCTWA)